home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / Extras / SysGen / utilities < prev    next >
Encoding:
Text File  |  1992-01-26  |  4.9 KB  |  206 lines
  1. \ Various utilities to be loaded from Buildsys
  2. \
  3. \  9/14/86 mdh -- made 'off' & 'on' inline.
  4. \ MOD: PLB 8/8/88 Coded XRDROP
  5. \ MOD: PLB 2/5/89 Made TIMES set #TIMES to 1
  6. \ 00001 PLB 11/20/91 Made RETURN and ?RETURN compile EXIT
  7. \       Had to change <RETURN> and <?RETURN> as well.
  8. \ 00002 PLB 12/31/91 Added FREEVAR and FCLOSEVAR
  9. \ 00003 mdh 26-jan-92 Fixed CR-NAME? stack depth when calling ?PAUSE
  10.  
  11. \ Copyright 1986 Delta Research
  12.  
  13. : CNT>RANGE  ( FROM CNT --- TO FROM )  OVER + SWAP ;
  14.  
  15. : [']  ( --- 'adr )  ( word --in-- )  ?COMP [compile] '   ; IMMEDIATE
  16.  
  17. : '>BODY  ( 'ADR --- BODY-ADR )   ; IMMEDIATE
  18.   ( This might be expanded to know about create-does> words ) 
  19. : '>NAME  ( 'ADR --- NAME-ADR )   >NAME   ;
  20.  
  21. BASE @ HEX
  22. : IMMEDIATE?  ( NAME-ADR --- FLAG )  C@  40 AND ; 
  23. BASE ! 
  24.  
  25. : ALIAS ( --- ) ( new-name OLD-NAME  --in-- )
  26.    [] ' >R CREATE  R> , 
  27.    DOES>   ( ??? <PFA> --- ??? )  @  INTERPRETING?
  28.    IF    RDROP EXECUTE 
  29.    ELSE  DUP  '>NAME  IMMEDIATE?
  30.          IF    RDROP EXECUTE
  31.          ELSE  CFA, ( Should check the SIZE and act correctly ) 
  32.          THEN  
  33.    THEN ;
  34.  
  35. \ 'alias' looks like a good word, but why sacrifice 'inline' speed? ...
  36. \ ALIAS 2DUP    DDUP
  37. \ ALIAS DSWAP   2SWAP
  38. \ ALIAS 2DROP   DDROP
  39. \ ALIAS D@      2@
  40. \ ALIAS D!      2! 
  41.  
  42. max-inline @  32 max-inline !   \ 00002
  43. : ddup   2dup     both ;
  44. : 2swap  dswap    both ;
  45. : ddrop  2drop    both ;
  46. : 2@     d@       both ;
  47. : 2!     d!       both ;
  48. max-inline !
  49.  
  50. EXISTS? XRDROP NOT
  51. .IF
  52. \ : XRDROP  ( X --- )  ( XN ... --R-- )
  53. \      R> SWAP
  54. \      BEGIN  ( RADDR CNT )  DUP 0 > 
  55. \      WHILE  1- RDROP
  56. \      REPEAT DROP >R ;
  57. \ XRDROP should be code that adds to RP
  58. \ Now it is!
  59. : XRDROP ( X -- ) ( XN . . X1 --R-- , drop from return stack )
  60.     [ $ E587 w,   \ asl.l   #2,tos   ( cell*)
  61.       $ DFC7 w,   \ adda.l  tos,a7
  62.       $ 2E1E w,   \ move.l  (a6)+,tos
  63.     ] INLINE
  64. ;
  65. .THEN
  66.  
  67. EXISTS? LOOP-DROP NOT
  68. .IF
  69. : LOOP-DROP [ BASE @ HEX 4CDF W, 60 W,  BASE ! ] INLINE ;
  70.      ( MOVEM RP@+,D5,D6  ) 
  71. .THEN 
  72.  
  73. EXISTS? BINARY  NOT
  74. .IF  : BINARY  2 BASE ! ;
  75. .THEN
  76.  
  77. : <RETURN>  ( --- )  ( N-CELLS --LOOP-- )  ( N --INLINE-- )
  78. \ Warning: this used to return TWO levels up but this caused
  79. \ problems with locals so we changed it in V3.0    00001
  80.     inline@ @ ( so that XRDROP never gets 0 )
  81.     r> cell+ swap \ get return address after inline data
  82.     xrdrop
  83.     loop-drop
  84.     >r  \ return to where we came from
  85. ;
  86.  
  87. \ EXISTS? USP@ NOT
  88. \ .IF 
  89. : USP@  ( --- ADR )  USP @ ; 
  90. \ .THEN 
  91.  
  92. : US-DEPTH  ( --- CELLS )  USP cell- USP@ - CELL/ ;
  93. : US-PICK   ( N --- NTH-CELL-OF-USER-STACK ) CELLS USP@ + @ ;
  94.  
  95. : DO-LOOP-NEST  ( --- CELLS )  US-DEPTH 1+
  96.     0  SWAP  1 
  97.     DO   I US-PICK DO_FLAG  = 
  98.          IF  1+
  99.          THEN 
  100.     LOOP 2* ( #OF CELLS/LOOP )  ;
  101.  
  102. : RETURN  ( --- )
  103.     do-loop-nest  ( #loop-cells ) dup
  104.     IF   compile <return> 2- ,
  105.     ELSE drop
  106.     THEN
  107. \ always compile exit so we can trap EXIT in CFA,     00001
  108.     compile EXIT
  109. ; IMMEDIATE
  110.  
  111. : <?RETURN>  ( FLAG --- flag )  ( N-CELLS --LOOP-- )  ( N --INLINE-- ) 
  112.      dup  \ save flag for ?exit   00001
  113.      IF
  114.          inline@  @
  115.          r> cell+ swap  \ return past inline data 00001
  116.          xrdrop loop-drop >r
  117.      ELSE  CELL INLINE+ 
  118.      THEN   ;  ( N Must not be zero! ) 
  119.  
  120. : ?EXIT   ( FLAG --- )  ( RADDR --R-- RADDR | )   ( exit if true ) 
  121.      IF  RDROP EXIT
  122.      THEN ;  ( MUST BE CALLED ) 
  123.      
  124. : ?RETURN  ( flag -runtime- ) ( -compiletime- )
  125.     do-loop-nest  ( #loop-cells ) dup
  126.     IF   compile <?return> 2- , 
  127.     ELSE drop
  128.     THEN
  129.     compile  ?EXIT \ 00001
  130. ; IMMEDIATE
  131.   
  132. \ : OFF  ( ADDR --- )  ( SET ADR VAL TO FALSE )  FALSE  SWAP ! inline ;
  133. \ : ON   ( ADDR --- )  ( SET ADR VAL TO FALSE )  TRUE   SWAP ! inline ;
  134.    
  135. \ VARIABLE #TIMES
  136. : TIMES  ( N --- ) #TIMES @ > 
  137.    IF   1 #TIMES +!  >IN  OFF
  138.    ELSE 1 #TIMES !  
  139.    THEN ;
  140.  
  141. \ All tested by BTD , sept 2 86
  142.  
  143.  
  144.  
  145. \ to provide a generic 'ID.' for LISTS of words, like VLIST, WORDS-LIKE, etc.
  146.  
  147.  
  148. variable #WORDS   variable LISTINDENT
  149.  
  150. : CR-NAME?  ( NFA --- )
  151.   linelimit @ ( C/L )  OUT @ - ( nfa diff )  dup $ 0f <= >r ( -r- flag )
  152.   SWAP C@    ( diff nfac@ )
  153.   $ 1F AND [ 2 CELLS ] LITERAL + <           r> or  ( -- flag )
  154.   IF    ( - 00003  2 x>r )
  155.         ?pause
  156.         ( - 00003  2 xr> )
  157.         CR    LISTINDENT @  out @ -  0 max spaces
  158.   THEN   ;
  159.  
  160. : .#WORDS  ( --- )  #WORDS @ >newline 5 .R ."  words " cr ;
  161.  
  162. : NEXTLISTCOL  ( -- )
  163.   linelimit @ out @ - $ 0f >
  164.   IF
  165.      out @  LISTINDENT @ -
  166.      $ ffff,fff0 and  $ 10 +
  167.      LISTINDENT @ +  out @ - spaces
  168.   THEN
  169. ;
  170.  
  171.  
  172. : ID.LIST  ( NFA --- )
  173.   DUP>r  CR-NAME? r> ID. NEXTLISTCOL
  174.   1 #WORDS +!  ;
  175.  
  176.  
  177. \ : ID.TAB?  ( nfa flag -- , if non-zero, print 'listing' fashion )
  178. \   IF
  179. \      ID.LIST
  180. \   ELSE
  181. \      ID.
  182. \   THEN
  183. \ ;
  184.  
  185.  
  186. : NFACount   ( nfa -- name count , like 'count' but limits to 31 )
  187.   dup 1+ swap c@ $ 1f and
  188. ;
  189.  
  190. \ -------------- Added 12/31/91 , 00002
  191.  
  192. : FREEVAR ( cell-addr -- , free memory pointed to in variable )
  193.     dup @ ?dup
  194.     IF freeblock
  195.     THEN
  196.     off
  197. ;
  198.  
  199. : FCLOSEVAR ( cell-addr -- , close file pointed to in variable )
  200.     dup @ ?dup
  201.     IF fclose
  202.     THEN
  203.     off
  204. ;
  205.  
  206.